module Hscm.Eval (eval) where

import Hscm.Value
import Hscm.Parse (parseHscms)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Except
import Data.IORef


eval :: HscmEnvRef -> HscmValue -> HscmIOResult (HscmEnvRef, HscmValue)
eval envRef val@(String _)  = return (envRef, val)
eval envRef val@(Integer _)  = return (envRef, val)
eval envRef val@(Double _)  = return (envRef, val)
eval envRef val@(Bool _)    = return (envRef, val)

eval envRef val@(Symbol varname) = do
    -- getVarInEnvRef :: HscmEnvRef -> String -> HscmIOResult HscmValue
    value <- getVarInEnvRef envRef varname 
    return (envRef, value)

eval envRef (List [Symbol "quote", val]) = return (envRef, val)

eval envRef (List [Symbol "if", pred, conseq, alt]) = do 
    (_, result) <- eval envRef pred
    if valueToBool result
        then eval envRef conseq
        else eval envRef alt

{-
    (cond ((< x 0) "Negative")
          ((= x 0) "Zero")
          ((> x 0) "Positive"))
-}
eval envRef (List (Symbol "cond" : branchs)) = do
    evalBranchs branchs
    where 
        evalBranchs :: [HscmValue] -> HscmIOResult (HscmEnvRef, HscmValue)
        evalBranchs [] = throwError $ Evaluate "All pred failed in `cond` expr"
        evalBranchs (b:bs) = do
            res <- chcekBranch b
            case res of
                Just value -> return (envRef, value) 
                Nothing    -> evalBranchs bs

        chcekBranch :: HscmValue -> HscmIOResult (Maybe HscmValue)
        chcekBranch (List [Symbol "else", retExpr]) = do
            (_, retValue) <- eval envRef retExpr
            return $ Just retValue
        chcekBranch (List [pred, retExpr]) = do
            (_, predResult) <- eval envRef pred
            if valueToBool predResult
                then do
                    (_, retValue) <- eval envRef retExpr
                    return $ Just retValue
                else return Nothing
        chcekBranch branch = throwError $ Evaluate $ "Except a list in `cond`, but got'" ++ show branch ++ "'" 

{-
    (begin (dispaly "hhh") (define x 12) ... 2333)
-}
eval envRef (List (Symbol "begin" : codes)) = do
    newEnvRef <- liftIO $ newIORef $ noVarEnv envRef
    (_, retValue) <- evalCodes newEnvRef codes
    return (envRef, retValue)
    where
        evalCodes :: HscmEnvRef -> [HscmValue] -> HscmIOResult (HscmEnvRef, HscmValue)
        evalCodes _ [] = throwError $ Evaluate "Empty list after `begin`"
        evalCodes envRef [code] = eval envRef code
        evalCodes envRef (code:codes) = do
            (envRef', _) <- eval envRef code
            evalCodes envRef' codes 

{-
    (let ((a 1) (b 1)) (+ a b))
-}
eval envRef (List [Symbol "let", (List defines), code]) = do
    -- Define all vars
    newEnvRef <- liftIO $ newIORef $ noVarEnv envRef
    definedEnvRef <- evalDefines newEnvRef defines
    (_, retValue) <- eval definedEnvRef code
    return (envRef, retValue)
    where
        evalDefines :: HscmEnvRef -> [HscmValue] -> HscmIOResult HscmEnvRef
        evalDefines envRef [] = return envRef
        evalDefines envRef (def:defs) = do
            envRef' <- evalDefine envRef def
            evalDefines envRef' defs

        evalDefine :: HscmEnvRef -> HscmValue -> HscmIOResult HscmEnvRef 
        evalDefine envRef (List [Symbol name, valueCode]) = do
            (_, value) <- eval envRef valueCode
            defineVarInEnvRef envRef name value
            return envRef
        evalDefine _ badDef = throwError $ Evaluate $ "Bad define format in `let`: '" ++ show badDef ++ "'"

eval envRef (List [Symbol "define", Symbol varName, form]) = do
    (_, value) <- eval envRef form
    defineVarInEnvRef envRef varName value
    return (envRef, value)

eval envRef (List [Symbol "define", List ((Symbol funcName) : params), body]) = do
    -- Create a lambda value
    let lambda = Lambda (map strValue params) body envRef
    -- Define lambda value into `envRef`
    defineVarInEnvRef envRef funcName lambda
    return (envRef, lambda)

eval envRef (List [Symbol "set!", Symbol varName, form]) = do
    (envRef', value) <- eval envRef form
    -- setVarInEnvRef :: HscmEnvRef -> String -> HscmValue -> HscmIOResult ()
    setVarInEnvRef envRef varName value
    return (envRef, value)

eval envRef (List [Symbol "lambda", List params, body]) = do
    let lambda = Lambda (map strValue params) body envRef
    return (envRef, lambda)

{-
    (list 1 2 3 (+ 1 2))
-}
eval envRef (List (Symbol "list" : elements)) = do
    evaledElements <- evalProcArgs envRef elements
    return (envRef, List evaledElements)

eval envRef (List [Symbol "load", String filePath]) = do
    context <- liftIO (readFile filePath)
    case parseHscms context of
        Left err -> throwError err
        Right values -> do
            finalEnvRef <- foldM updateEnvRef envRef values
            return (finalEnvRef, String filePath)
        where
            updateEnvRef :: HscmEnvRef -> HscmValue -> HscmIOResult HscmEnvRef
            updateEnvRef lastEnvRef value = do
                (nextEnvRef, _) <- eval lastEnvRef value
                return nextEnvRef

eval envRef (List (lst@(List values) : rest)) = do
    (envRef', value) <- eval envRef lst
    eval envRef' (List (value:rest))

{-

    1. eval all arguments:

        mapM :: (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b)
        args :: [HscmValue]
        eval :: HscmValue -> HscmIOResult HscmValue
        mapM :: (HscmValue -> HscmIOResult HscmValue) -> [HscmValue] -> HscmIOResult [HscmValue]

        Example:

        - mapM (Just . (*2)) [1, 2, 3] => Just [2, 4, 6]
        - mapM (\x -> if x == 1 then Nothing else Just 2) [1, 2, 3] => Nothing
        - mapM (\x -> if x == 1 then Nothing else Just 2) [2, 2, 3] => Just [2, 2, 2]

    2. apply func
        
        Monad m => m a -> (a -> m b) -> m b
        (mapM (eval env) args) :: HscmIOResult [(HscmEnv, HscmValue)]
        (apply func env) :: [HscmValue] -> HscmIOResult (HscmEnv, HscmValue)

        Exmaple:

        - Just 1 >>= (\x -> Just $ 2 * x ) => Just 2
        - Nothing >>= (\_ -> Just 1) => Nothing
-}
eval envRef (List (Symbol func : args)) = evalProcArgs envRef args >>= apply func envRef

eval envRef (List (Lambda params body initEnvRef : args)) = do 
    evaledArgs <- evalProcArgs envRef args
    (_, retValue) <- applyLambda params evaledArgs body initEnvRef
    return (envRef, retValue)

eval envRef badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm


valueToBool :: HscmValue -> Bool
valueToBool (Bool False) = False
valueToBool _            = True


evalProcArgs :: HscmEnvRef -> [HscmValue] -> HscmIOResult [HscmValue]
evalProcArgs envRef args = mapM (eval envRef) args >>= (\envArgs -> return $ map snd envArgs)


apply :: String -> HscmEnvRef -> [HscmValue] -> HscmIOResult (HscmEnvRef, HscmValue)
apply funcName envRef args = do
    -- Search func from current envRef
    value <- getVarInEnvRef envRef funcName

    case value of
        -- Apply in primitive proc
        (PrimitiveProc function) -> resultToIOResult $ do 
            retValue <- function args
            return (envRef, retValue)

        -- Apply in io primitive proc
        (IOPrimitiveProc function) -> do
            retValue <- function args
            return (envRef, retValue)
        
        -- Apply user define proc
        (Lambda params body initEnvRef) -> do 
            (_, retValue) <- applyLambda params args body initEnvRef
            return (envRef, retValue)

        _ -> throwError $ NotFunction "Call not proc value" funcName


applyLambda :: [String] -> [HscmValue] -> HscmValue -> HscmEnvRef -> HscmIOResult (HscmEnvRef, HscmValue)
applyLambda params args body initEnvRef = if (length args) /= (length params)
    then throwError $ NumArgs (length params) args 
    else do
        let argsVarMap = newArgVarMap params args
        newEnvRef <- liftIO $ newIORef $ newEnv argsVarMap initEnvRef
        eval newEnvRef body